home *** CD-ROM | disk | FTP | other *** search
/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / _tile / test / queues1 < prev    next >
Encoding:
Text File  |  1992-04-19  |  3.2 KB  |  145 lines
  1. #include <tile$lib>.structures
  2. #include <tile$lib>.blocks
  3.  
  4. memory locals string blocks structures queues definitions
  5.  
  6. struct.type QUEUE ( -- )
  7.   ptr +succ ( queue -- addr) private
  8.   ptr +pred ( queue -- addr) private
  9.   ptr +name
  10.   long +id
  11. struct.init ( queue -- )
  12.   dup over +succ ! dup +pred !
  13. struct.end 
  14.  
  15. : succ ( queue -- succ)
  16.   +succ @
  17. ;
  18.  
  19. : pred ( queue -- pred)
  20.   +pred @
  21. ;
  22.  
  23. : size-queue ( queue -- num)
  24.   0 swap dup >r                                ( Save pointer to queue header)
  25.   begin
  26.     swap 1+ swap +succ @               ( Increment size and step to next)
  27.     dup r@ =                           ( Is this the last element?)
  28.   until
  29.   r> 2drop                             ( Drop parameters and return size)
  30. ;
  31.  
  32. : map-queue ( queue block[item -- ] -- )
  33.   over >r                              ( Save pointer to queue header)
  34.   begin
  35.     over +succ @ >r                    ( Save pointer to next item)
  36.     dup >r                             ( Save block on return stack)
  37.     call                               ( Call the block with the item)
  38.     2r> tuck                           ( Restore the parameters)
  39.     r@ =                               ( Check if end of queue)
  40.   until
  41.   r> drop 2drop                        ( Drop all temporary parameters)
  42. ;
  43.  
  44. : ?map-queue ( queue block[item -- bool] -- )
  45.   over >r                              ( Save pointer to queue header)
  46.   begin
  47.     over +succ @ >r                    ( Save pointer to next item)
  48.     dup >r                             ( Save block on return stack)
  49.     call                               ( Call the block with the item)
  50.     if 2r> true                                ( Exit the iteration)
  51.     else
  52.       2r> tuck                         ( Restore the parameters)
  53.       r@ =                             ( Check if end of queue)
  54.     then
  55.   until
  56.   r> drop 2drop                        ( Drop all temporary parameters)
  57. ;
  58.  
  59. : ?member-queue ( element queue -- bool)
  60.   dup >r                               ( Save pointer to queue header)
  61.   begin
  62.     2dup =                             ( Is this the element?)
  63.     if 2drop r> drop true exit then    ( Well drop the parameters and return)
  64.     +succ @ dup r@ =                   ( Step to the next. Last element?)
  65.   until
  66.   r> drop 2drop false
  67. ;
  68.  
  69. : print-entry ( queue -- )
  70.   dup +name @ $print space +id @ . ;
  71.  
  72. : print-queue ( queue -- )
  73.   block[ print-entry cr ]; map-queue
  74. ;
  75.  
  76. variable queue.head
  77.  
  78. : add-id { name id | queue -- }
  79.   16 malloc -> queue
  80.   queue as QUEUE initiate
  81.   name queue +name !
  82.   id queue +id !
  83.   queue.head @
  84.   if
  85.     queue queue.head @ enqueue
  86.   else
  87.     queue queue.head !
  88.   then
  89. ;
  90.  
  91. : locate-id { id | p queue -- q }
  92.   nil -> queue
  93.   queue.head @
  94.   if
  95.     queue.head @ dup -> p
  96.     size-queue 0
  97.     do
  98.       p +id @ id =
  99.       if
  100.         p -> queue leave
  101.       else
  102.         p succ -> p
  103.       then
  104.     loop
  105.   then
  106.   queue
  107. ;
  108.  
  109. : remove-entry ( queue -- )
  110.   dup dequeue free
  111. ;
  112.  
  113. : setup-head
  114.   nil queue.head !
  115. ;
  116.  
  117. forth only
  118.  
  119. string queues
  120.  
  121. setup-head
  122.  
  123. .( Add some initial entries...) cr
  124.  
  125. " Peter" 1 add-id
  126. " Derek" 2 add-id
  127. " Tom"   3 add-id
  128.                  
  129. .( Print out entries...) cr
  130.  
  131. queue.head @ print-queue
  132.  
  133. .( Locate some entries...) cr
  134.  
  135. 3 locate-id print-entry cr
  136. 1 locate-id print-entry cr
  137.  
  138. .( Bump off one entry...) cr
  139.  
  140. 1 locate-id remove-entry
  141.  
  142. queue.head @ print-queue
  143.  
  144. bye
  145.